home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / extend.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-06-09  |  7.0 KB  |  278 lines
  1. /*
  2.  *
  3.  * e x t e n d . c            -- All the stuff dealing with 
  4.  *                       extended types
  5.  *
  6.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  7.  * 
  8.  *
  9.  * Permission to use, copy, and/or distribute this software and its
  10.  * documentation for any purpose and without fee is hereby granted, provided
  11.  * that both the above copyright notice and this permission notice appear in
  12.  * all copies and derived works.  Fees for distribution or use of this
  13.  * software or derived works may only be charged with express written
  14.  * permission of the copyright holder.  
  15.  * This software is provided ``as is'' without express or implied warranty.
  16.  *
  17.  * This software is a derivative work of other copyrighted softwares; the
  18.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  19.  *
  20.  *
  21.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  22.  *    Creation date: 15-Mar-1995 11:31
  23.  * Last file update: 10-Jun-1996 00:02
  24.  */
  25.  
  26. #include "stk.h"
  27. #include "extend.h"
  28.  
  29. #define EXT_TYPE_DESCR(x)    (xtypes[TYPE(x)- tc_start_extd])
  30.  
  31. static STk_extended_scheme_type *xtypes[tc_stop_extd-tc_start_extd+1];
  32. static int extended_type_stamp = tc_start_extd;
  33.  
  34.  
  35. /******************************************************************************
  36.  * 
  37.  * Extended Types
  38.  *
  39.  ******************************************************************************/
  40.  
  41. /***
  42.  ***
  43.  *** Default functions
  44.  ***
  45.  ***/ 
  46.  
  47. static void internal_display(SCM obj, SCM port, int mode)
  48. {
  49.   sprintf(STk_tkbuffer, "#<%s %lx>", (EXT_TYPE_DESCR(obj))->type_name, 
  50.                        (unsigned long) obj);
  51.   Puts(STk_tkbuffer, PORT_FILE(port));
  52. }
  53.  
  54. static SCM internal_apply(SCM obj, SCM args, SCM env)
  55. {
  56.   Err("apply: bad procedure", obj);
  57.   return UNDEFINED; /* to make the compiler happy */
  58. }
  59.  
  60. static SCM internal_compare(SCM x, SCM y, int equalp)
  61. {
  62.   return Ntruth;
  63. }
  64.  
  65. /***
  66.  *** 
  67.  *** Utilities
  68.  *** 
  69.  ***/
  70. void STk_extended_mark(SCM x)
  71. {
  72.   STk_extended_scheme_type *p= EXT_TYPE_DESCR(x);
  73.   if (p->gc_mark_fct) (*(p->gc_mark_fct))(x);
  74. }
  75.  
  76. void STk_extended_sweep(SCM x)
  77. {
  78.   STk_extended_scheme_type *p = EXT_TYPE_DESCR(x);
  79.   if (p->gc_sweep_fct) (*(p->gc_sweep_fct))(x);
  80. }
  81.  
  82. SCM STk_extended_apply(SCM x, SCM args, SCM env)
  83. {
  84.   return (*(EXT_TYPE_DESCR(x)->apply_fct))(x, args, env);
  85. }
  86.  
  87. void STk_extended_display(SCM x, SCM port, int mode)
  88. {
  89.   (*(EXT_TYPE_DESCR(x)->display_fct))(x, port, mode);
  90. }
  91.  
  92. int STk_extended_procedurep(SCM x)
  93. {
  94.   return (EXT_TYPE_DESCR(x)->flags && EXT_ISPROC);
  95. }
  96.  
  97. int STk_extended_eval_parameters(SCM x)
  98. {
  99.   return (EXT_TYPE_DESCR(x)->flags && EXT_EVALPARAM);
  100. }
  101.  
  102. SCM STk_extended_compare(SCM x, SCM y, int equalp)
  103. {
  104.   /* One of x or y (at least) is extended. */
  105.   return EXTENDEDP(x) ? (*(EXT_TYPE_DESCR(x)->compare_fct))(x, y, equalp)
  106.               : (*(EXT_TYPE_DESCR(y)->compare_fct))(x, y, equalp);
  107. }
  108.  
  109. /******************************************************************************
  110.  * 
  111.  * C-pointer
  112.  *
  113.  ******************************************************************************/
  114.  
  115. typedef void (*STk_disp_function)(SCM x, SCM port, int mode);
  116.  
  117. static int Cpointer_id                 = 0;
  118. static int size                       = 0;
  119. static STk_disp_function *display_array = NULL;
  120.  
  121.  
  122. static void Cpointer_default_display(SCM obj, SCM port, int mode)
  123. {
  124.   sprintf(STk_tkbuffer, "#<C-pointer %d %lx>", EXTID(obj), EXTDATA(obj));
  125.   Puts(STk_tkbuffer, PORT_FILE(port));
  126. }
  127.  
  128.  
  129. void STk_Cpointer_display(SCM obj, SCM port, int mode)
  130. {
  131.   (*(display_array[EXTID(obj)]))(obj, port, mode);
  132. }
  133.  
  134.  
  135. /******************************************************************************
  136.  *
  137.  * C variable 
  138.  *
  139.  ******************************************************************************/
  140.  
  141. static Tcl_HashTable Cvars;
  142. static C_hash_table_initialized = 0;
  143.  
  144. struct get_n_set_box {
  145.   SCM (*getter)();
  146.   void (*setter)();
  147. };
  148.  
  149.           
  150. SCM STk_apply_getter_C_variable(char *var)
  151. {
  152.   Tcl_HashEntry *entry;
  153.   
  154.   if (entry = Tcl_FindHashEntry(&Cvars, var)) {
  155.     struct get_n_set_box *p = (struct get_n_set_box *) Tcl_GetHashValue(entry);
  156.     
  157.     return (*(p->getter))(var);
  158.   }
  159.   else {
  160.     fprintf(STk_stderr, "internal error: %s variable has no getter!!\n", var);
  161.     return UNDEFINED;    
  162.   }
  163. }
  164.  
  165. void STk_apply_setter_C_variable(char *var, SCM value)
  166. {  
  167.   Tcl_HashEntry *entry;
  168.   
  169.   if (entry = Tcl_FindHashEntry(&Cvars, var)) {
  170.     struct get_n_set_box *p = (struct get_n_set_box *) Tcl_GetHashValue(entry);
  171.     
  172.     (*(p->setter))(var, value);
  173.   }
  174.   else
  175.     fprintf(STk_stderr, "internal error: %s variable has no setter!!\n", var);
  176. }
  177.  
  178.   
  179. /******************************************************************************
  180.  *
  181.  * Extended types and C-pointer User interface
  182.  *
  183.  ******************************************************************************/
  184.  
  185. int STk_add_new_type(STk_extended_scheme_type *p)               
  186. {
  187.   if (!p) Err("bad new type description", NIL);
  188.   
  189.   /* Set the apply procedure if not defined */
  190.   if (!p->apply_fct) p->apply_fct = internal_apply;
  191.  
  192.   /* Replace NULL display function by a default function */
  193.   if (!p->display_fct) p->display_fct = internal_display;
  194.  
  195.   /* Replace NULL compare function by a default function */
  196.   if (!p->compare_fct) p->compare_fct = internal_compare;
  197.  
  198.   /* Store the new type descriptor in the xtypes array */
  199.   xtypes[extended_type_stamp - tc_start_extd] = p;
  200.  
  201.   return extended_type_stamp++;
  202. }
  203.  
  204. void STk_add_new_primitive(char *fct_name, int fct_type, struct obj * (*fct_ptr)())
  205. {
  206.   SCM z;
  207.  
  208.   NEWCELL(z, fct_type);
  209.   z->storage_as.subr0.name = fct_name;
  210.   z->storage_as.subr0.f    = fct_ptr;
  211.   VCELL(Intern(fct_name))  = z;
  212. }
  213.  
  214. SCM STk_eval_C_string(char *s, SCM env)
  215. {
  216.   SCM tmp = STk_internal_eval_string(s, ERR_OK, env);
  217.   return tmp == EVAL_ERROR ? NULL: tmp;
  218. }
  219.  
  220.              /*************************/
  221.  
  222. int STk_new_Cpointer_id(void (*display_func)(SCM x, SCM port, int mode))
  223. {
  224.   if (++Cpointer_id >= size) {
  225.     if (display_array == NULL) {
  226.       display_array = must_malloc(10*sizeof (STk_disp_function));
  227.       size = 10;
  228.     }
  229.     else {
  230.       size += size / 2;
  231.       display_array = must_realloc(display_array, 
  232.                    size * sizeof (STk_disp_function));
  233.     }
  234.   }
  235.   /* store function in array */
  236.   display_array[Cpointer_id]= display_func? display_func : Cpointer_default_display;
  237.   return Cpointer_id;
  238. }
  239.  
  240. SCM STk_make_Cpointer(int Cpointer_id, void *ptr, int staticp)
  241. {
  242.   register SCM z;
  243.  
  244.   NEWCELL(z, tc_Cpointer);
  245.   EXTDATA(z)    = ptr;
  246.   EXTID(z)      = Cpointer_id;
  247.   EXTSTATICP(z) = staticp;
  248.   return z;
  249. }
  250.  
  251.              /*************************/
  252.  
  253. void STk_define_C_variable(char *var, SCM (*getter)(), void (*setter)())
  254. {
  255.   Tcl_HashEntry *entry;
  256.   int new;
  257.   struct get_n_set_box *p;
  258.  
  259.   if (!C_hash_table_initialized) {
  260.     /* First C-var. Create Hash table */
  261.     Tcl_InitHashTable(&Cvars, TCL_STRING_KEYS);
  262.     C_hash_table_initialized = 1;
  263.   }
  264.   
  265.   p         = must_malloc(sizeof(struct get_n_set_box));
  266.   p->getter = getter;
  267.   p->setter = setter;
  268.   entry     = Tcl_CreateHashEntry(&Cvars, var, &new);
  269.   if (!new) {
  270.     fprintf(STk_stderr, "Attempt to multi-define C variable `%s' !!\n", var);
  271.     return;
  272.   }
  273.   Tcl_SetHashValue(entry, p);
  274.  
  275.   /* Now enter variable in obarray and set its info field to C variable */
  276.   Intern(var)->cell_info = CELL_INFO_C_VAR;
  277. }
  278.